home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / CodeWarrior interface / code-warrior-interface.lisp next >
Encoding:
Text File  |  1994-12-13  |  7.3 KB  |  239 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode: LISP; Package: CODE-WARRIOR; Syntax: Common-lisp; Base: 10; -*-
  2. ;;;
  3. ;;; Nov 28, Ray Pelletier, adapted to Code Warrior <pelletier@cmu.edu>
  4. ;;;
  5. ;;; Thr Nov 14 1991 by Guillaume Cartier <cartier@math.uqam.ca>
  6. ;;; think-c.lisp
  7. ;;;
  8. ;;;
  9. ;;; *****************************************************************
  10. ;;; General License Agreement and Lack of Warranty ******************
  11. ;;; *****************************************************************
  12. ;;;
  13. ;;; This software is distributed in the hope that it will be useful (both
  14. ;;; in and of itself), but WITHOUT ANY WARRANTY. The author does not accept
  15. ;;; responsibility to anyone for the consequences of using it or for whether
  16. ;;; it serves any particular purpose or works at all. No warranty is made
  17. ;;; about the software or its performance.
  18. ;;;
  19. ;;; The current version of this software may be obtained by anonymous ftp
  20. ;;; from cambridge.apple.com in the directory pub/MCL/CONTRIB.
  21. ;;;
  22. ;;; Please send bug reports, comments, questions and suggestions to
  23. ;;; cartier@math.uqam.ca. I would also appreciate receiving any changes
  24. ;;; or improvements you may make.
  25. ;;;
  26. ;;; *****************************************************************
  27. ;;; CW interface ************************************************
  28. ;;; *****************************************************************
  29. ;;;
  30. ;;; This interface consist of some lisp files and C header
  31. ;;; files, enabling one to easily use CodeWarrior functions in MCL. An
  32. ;;; example is also provided.
  33. ;;;
  34. ;;; Very special thanks to the MCL team, they have always been very
  35. ;;; generous of their time in responding promptly to any questions I had.
  36. ;;;
  37. ;;; *****************************************************************
  38. ;;; Revision History ************************************************
  39. ;;; *****************************************************************
  40. ;;;
  41. ;;; 25/01/91   - Posted the code for the first time at cambridge.
  42. ;;; 14/11/91   - Converted the code to MCL2.0b1.
  43. ;;; 10/12/94   - Modified to call CodeWarrior Code Resources - Ray Pelletier
  44. ;;;
  45.  
  46.  
  47. (require :ff)
  48. (provide :code-warrior)
  49.  
  50. (defpackage "CODE-WARRIOR"
  51.   (:use "COMMON-LISP" "CCL")
  52.   (:import-from "CCL" "DEF-MACTYPE" "MAKE-MACTYPE" "%VREFLET")
  53.   (:export "*CODE-WARRIOR-FOLDER*"
  54.            "DEFCMODULE"
  55.            "DEFAULT-RESOURCE-FILE"
  56.            "LOAD-CMODULE"
  57.            "CLOSE-CMODULE"
  58.            ;;"%ALLOCATE-DOUBLE" ;;someone else can figure this out
  59.            ;;"%MAKE-DOUBLE"
  60.            ;;"%GET-DOUBLE"
  61.            ;;"%PUT-DOUBLE"
  62.            ))
  63.  
  64. (in-package "CODE-WARRIOR")
  65.  
  66.  
  67. ;;; ***********************
  68. ;;; Global stuff **********
  69. ;;; ***********************
  70.  
  71.  
  72. (defvar *CODE-WARRIOR-FOLDER*
  73.   "Alcatraz:CodeWarrior:")
  74.  
  75. (defvar *CMODULE-RESOURCE-TYPE*
  76.   "TCCD")
  77.  
  78. (defvar *CMODULES-TABLE*
  79.   (make-hash-table))
  80.  
  81. (defvar *CMODULES*
  82.   nil)
  83.  
  84.  
  85. (defstruct CMODULE
  86.   name
  87.   variables
  88.   functions
  89.   resource-file
  90.   refnum)
  91.  
  92.  
  93. (defun GET-CMODULE (module-name)
  94.   (or (gethash module-name *cmodules-table*)
  95.       (error "Unknown C module ~a ." module-name)))
  96.  
  97.  
  98. ;;; *****************************
  99. ;;; CModule definition **********
  100. ;;; *****************************
  101.  
  102.  
  103. (defmacro DEFCMODULE (name &key variables functions
  104.                                   (resource-file (default-resource-file name)))
  105.   `(progn
  106.      (defvar ,name)
  107.      (setf (gethash ',name *cmodules-table*)
  108.            (make-cmodule
  109.             :name          ',name
  110.             :variables     ',variables
  111.             :functions     ',(mapcar (function car) functions)
  112.             :resource-file ,resource-file))
  113.      (pushnew ',name *cmodules*)
  114.      ,@(mapcar (function
  115.                  (lambda (symb)
  116.                    `(defvar ,symb)))
  117.                variables)
  118.      ,@(mapcan (function
  119.                  (lambda (spec)
  120.                    (apply (function expand-function-spec) name spec)))
  121.                functions)
  122.      ',name))
  123.  
  124.  
  125. (defun EXPAND-FUNCTION-SPEC (savedA4 symb argstype &optional restype)
  126.   (let* ((args     (loop for arg in argstype
  127.                          collect (if (keywordp arg)
  128.                                    (copy-symbol arg)
  129.                                    (intern (write-to-string arg)))))
  130.          (lispargs (loop for x in argstype for y in args
  131.                          for type = (if (keywordp x) x (second x))
  132.                          when (eq type :lisp) collect y)))
  133.     (list
  134.      `(defvar ,symb)
  135.      `(defun ,symb ,args
  136.         (%vreflet ,(mapcar (function list) lispargs lispargs)
  137.           (ff-call ,symb :a4 ,savedA4
  138.                    ,@(loop for x in (reverse args)
  139.                            collect :ptr collect x)
  140.                    ,(or restype :novalue)))))))
  141.  
  142.  
  143. (defun DEFAULT-RESOURCE-FILE (name)
  144.   (merge-pathnames
  145.     *code-warrior-folder*
  146.     (symbol-name name)))
  147.  
  148.  
  149. ;;; *********************
  150. ;;; The loader **********
  151. ;;; *********************
  152.  
  153.  
  154. (defun LOADER-IMPORT (loader a4 symb)
  155.   (with-pstrs ((str (symbol-name symb)))
  156.     (let ((add (ff-call loader :a4 a4 :ptr str :a0)))
  157.       (if (%null-ptr-p add)
  158.           (error "Undefined C function ~a ." symb)
  159.         (set symb add)))))
  160.  
  161.  
  162. (defun LOAD-CMODULE (module-name)
  163.   (let ((module (get-cmodule module-name)))
  164.     (setf (cmodule-refnum module)
  165.           (open-resource-file (truename (cmodule-resource-file module))))
  166.     (let ((res (get-resource *cmodule-resource-type* (symbol-name module-name))))
  167.       (cond
  168.        ((null res)
  169.         (error "Can't find the C module ~a ." module-name))
  170.        (t ;(#_DetachResource res)
  171.           (let* ((loader (%get-ptr res))
  172.                  (a4     (ff-call loader :ptr (%null-ptr) :a0)))
  173.             ;; Ask resource for A4  <==
  174.             (set module-name a4)
  175.             (dolist (symb (cmodule-variables module)) (loader-import loader a4 symb))
  176.             (dolist (symb (cmodule-functions module)) (loader-import loader a4 symb))))))))
  177.  
  178.  
  179. (defun CLOSE-CMODULE (module-name)
  180.   (let ((refnum (cmodule-refnum (get-cmodule module-name))))
  181.     (unless (eq (#_CurResFile) refnum)
  182.       (close-resource-file refnum))))
  183.  
  184. (def-load-pointers RESTORE-CMODULES ()
  185.   (dolist (cmodule *cmodules* t)
  186.     (load-cmodule cmodule)))
  187.  
  188. #|
  189. ;;; ********************************
  190. ;;; ******** CW's doubles **********
  191. ;;; ********************************
  192.  
  193. ;; Must to be completed by someone who needs these...
  194.  
  195. (defun (setf %GET-DOUBLE) (data pointer &optional (offset 0))
  196.   (%put-double pointer data offset))
  197.  
  198.  
  199. (defun %ALLOCATE-DOUBLE ()
  200.   (make-record :double))
  201.  
  202. (defun %MAKE-DOUBLE (float)
  203.   (let ((ptr (%allocate-double)))
  204.     (setf (%get-double ptr) float)
  205.     ptr))
  206.  
  207. (defun %GET-DOUBLE (pointer &optional (offset 0))
  208.   (let ((ptr (%inc-ptr pointer offset)))
  209.     (ccl::%get-x2float ptr)))
  210.  
  211. (defun %PUT-DOUBLE (pointer float &optional (offset 0))
  212.   (let ((ptr (%inc-ptr pointer offset)))
  213.     (ccl::%float2x (float float) ptr)))
  214. |#
  215. ;;
  216. ;; If you're using MCL2.0b3 or upwards, you can use the following
  217. ;; definition to ease working with doubles. In fact, you could probably
  218. ;; use it also in MCL2.0b1 with small changes (MCL2.0b1 does'nt recognize
  219. ;; the :access-operator keyword option to DEF-MACTYPE).
  220. ;;
  221.  
  222. ;;; **************************
  223. ;;; Resources stuff **********
  224. ;;; **************************
  225.  
  226.  
  227. (defun OPEN-RESOURCE-FILE (file)
  228.   (with-pstrs ((pf (mac-namestring (truename file))))
  229.     (#_OpenResFile pf)))
  230.  
  231. (defun CLOSE-RESOURCE-FILE (refnum)
  232.   (#_CloseResFile refnum))
  233.  
  234.  
  235. (defun GET-RESOURCE (type name)
  236.   (let ((res (with-pstrs ((ps name))
  237.                (#_GetNamedResource type ps))))
  238.     (unless (%null-ptr-p res) res)))
  239.